home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #015 (19xx)(Amiga User Group Deutschland e.V.).zip / Franz PD Disk #015 (19xx)(Amiga User Group Deutschland e.V.).adf / ViceTracer / Vice-Tracer < prev    next >
Text File  |  1986-10-22  |  8KB  |  291 lines
  1. '   V I C E - T R A C E
  2. '     geschrieben von
  3. '      AMIGA - VICE
  4. '(Roger Hassler/Neustädter Str.14/3252 Bad Mnder 1)
  5. ' als Freesoftprogramm
  6. WINDOW CLOSE 1:CLEAR,15000,5000
  7. SCREEN 2,320,256,4,1:WINDOW 2,,,0,2
  8. DEFINT I,j,x,y,f,n:DIM ca(3):DIM grh(81)
  9. GOSUB palettea
  10. PRINT
  11. PRINT
  12. PRINT"          A M I G A - V I C E ©"
  13. FOR I=1 TO 10000
  14. NEXT I
  15. CLS
  16. PRINT
  17. PRINT
  18. PRINT"          p r e s e n t i e r t
  19.  
  20. FOR I=1 TO 10000
  21. NEXT I
  22. CLS
  23. PRINT
  24. PRINT"     eine ROGER HASSLER  Produktion"
  25. FOR I=1 TO 10000
  26. NEXT I
  27. CLS
  28. PRINT
  29. PRINT
  30. PRINT"   ***************************** "
  31. PRINT"   *    V I C E - T R A C E R  * "
  32. PRINT"   ***************************** "
  33. PRINT
  34. PRINT"  Der Spiegel der Wirklichkeit ...  "
  35. FOR I=1 TO 17000
  36. NEXT I
  37. CLS
  38. PRINT
  39. PRINT
  40. PRINT" ************************************ "
  41. PRINT" *    V I C E - T R A C E R  1.1a   * "
  42. PRINT" ************************************ "
  43. PRINT
  44. PRINT"              geschrieben von "
  45. PRINT                
  46. PRINT"            A M I G A - V I C E"
  47. PRINT"        als Publick-Domain Programm"
  48. PRINT
  49. PRINT
  50. INPUT"high/low Resolution (1/2) ";nf
  51. IF nf=1 THEN px=632:py=508:ngg=40:nn$="-h" ELSE px=312:py=252:ngg=25:nn$="-l"
  52. DIM g#(ngg)
  53. INPUT"Glas(1)/Diamant(2)/Wasser(3)-Kugel ";GDW$
  54. IF GDW$="1"THEN Kugel%=2.56
  55. IF GDW$="2"THEN Kugel%=5.84
  56. IF GDW$="3"THEN Kugel%=1.78
  57. INPUT"Rechnen/Show (r/s) ";A$
  58. IF A$="s" THEN ON nf GOTO showa,showb
  59. GOSUB aufbau
  60.  
  61. INPUT"Probelauf (j,n) ";b$
  62. IF b$="n" THEN GOSUB nadenn ELSE GOSUB probe
  63. FOR y=lka TO -bka STEP -1
  64. yh=py*.5-y
  65. IF yh>7 THEN IF MOUSE(0)<0  AND b$="n" THEN GOSUB savebild
  66. IF yh=8 THEN GET(280,0)-(328,7),grh
  67. IF b$="j" OR yh>7 THEN LOCATE 1,36:PRINT y+bka
  68. h1=hsr1+my1*y:h2=hsr2+my2*y:h3=hsr3+my3*y
  69. FOR x=-xm TO xm
  70. farbe=0:ffn=0:faam=0:ns=0
  71. ca1=ca(1):ca2=ca(2):ca3=ca(3)
  72. crr1=llx1*x+h1:crr2=llx2*x+h2:crr3=h3
  73. GOSUB raytracing
  74. PSET(x+xm,bka-y),farbe
  75. NEXT x
  76. NEXT y
  77. BEEP
  78. IF b$="n" THEN GOSUB savebild
  79. SLEEP:SLEEP:SLEEP:RUN
  80. palettea:
  81. WINDOW OUTPUT 2
  82. PALETTE 0,0,0,0:PALETTE 1,0,0,.4:PALETTE 2,0,0,.6:PALETTE 3,0,0,.8
  83. PALETTE 4,0,0,1:PALETTE 5,0,.2,0:PALETTE 6,0,.5,0:PALETTE 7,0,.7,0
  84. PALETTE 8,0,.8,0:PALETTE 9,0,1,0:PALETTE 10,.2,0,0:PALETTE 11,.4,0,0
  85. PALETTE 12,.6,0,0:PALETTE 13,.5,0,0:PALETTE 14,1,0,0:PALETTE 15,1,1,1
  86. COLOR 4,0
  87. RETURN
  88. paletteb:
  89. WINDOW OUTPUT 2
  90. a1=2/15:a2=5/15:a3=7/15:a4=7/15:a5=8/15
  91. PALETTE 16,a1,a1,a1:PALETTE 17,a2,a2,.4:PALETTE 18,a3,a3,.6:PALETTE 19,a4,a4,.8
  92. PALETTE 20,a5,a5,1:PALETTE 21,a1,.2,a1:PALETTE 22,a2,.4,a2:PALETTE 23,a3,.6,a3
  93. PALETTE 24,a4,.8,a4:PALETTE 25,a5,1,a5:PALETTE 26,.2,a1,a1:PALETTE 27,.4,a2,a2
  94. PALETTE 28,.6,a3,a3:PALETTE 29,.8,a4,a4:PALETTE 30,1,a5,a5:PALETTE 31,0,0,0
  95. RETURN
  96. probe:
  97. px=85:py=70
  98. GOSUB init:lka=bka
  99. IF nf=1 THEN RETURN
  100. SCREEN 2,320,256,5,1:WINDOW 2,,(0,0)-(311,242),0,2
  101. GOSUB palettea:GOSUB paletteb
  102. RETURN
  103. nadenn:
  104. IF nf=1 THEN
  105. SCREEN 2,640,525,4,4:WINDOW 2,,(0,9)-(631,508),0,2
  106. GOSUB palettea
  107. ELSE
  108. SCREEN 2,321,280,5,1:WINDOW 2,,(0,9)-(312,262),0,2
  109. GOSUB palettea:GOSUB paletteb
  110. END IF
  111. GOSUB init
  112. INPUT"Neues Bild/Fortsetzung (1/2) ";A$
  113. INPUT"Name des Bildes ? ",na$:CLS
  114. IF A$="1" THEN lka=bka ELSE GOSUB loadbild:lka=bka-I+1:GET(280,0)-(328,7),grh
  115. RETURN
  116. aufbau:
  117. RESTORE
  118. nk=3:DIM ku(nk,4)
  119. FOR I=0 TO nk
  120. FOR j=0 TO 4
  121. READ ku(I,j)
  122. NEXT j
  123. NEXT I
  124. DATA 50,-50,200,200,3
  125. DATA 8,11,48,7,1
  126. DATA 9,42,46,13,1
  127. DATA 6,16,27,5,2
  128. REM ARTEN=Spiegelkugel:1,Glas:2,Lichtquelle:3 !
  129. lqq1=ku(0,1):lqq2=ku(0,2):lqq3=ku(0,3)
  130. RETURN
  131. init:
  132. CLS:farbe=0
  133. xm=px*.5:bka=py*.5
  134. bb=.265:bh=.19:brz1=Kugel%:brz2=1/brz1
  135. PRINT"Ideale Werte währen :"
  136. PRINT"0,0,18"
  137. PRINT"5,10,-2.6"
  138. PRINT"0.28"
  139. PRINT
  140. INPUT "Bildschirmmittelpunkt: ";bm1,bm2,bm3
  141. INPUT "Blickrichtung:         ";hsr1,hsr2,hsr3
  142. INPUT "Abstand vom Bildschirm:";ba
  143. IF (hsr1=0 AND hsr2=0) OR ba=0 THEN GOTO init
  144. llx1=hsr2:llx2=-hsr1:llx3=0
  145. bx=SQR(llx1*llx1+llx2+llx3*llx3)
  146. llx1=(llx1*bb)/(bx*px):llx2=(llx2*bb)/(bx*px):llx3=(llx3*bb)/(bx*px)
  147. my1=-hsr1*hsr3:my2=-hsr2*hsr3:my3=hsr2*hsr2+hsr1*hsr1
  148. by=SQR(my1*my1+my2*my2+my3*my3)
  149. my1=(my1*bh)/(by*py):my2=(my2*bh)/(by*by):my3=(my3*bh)/(by*py)
  150. br=SQR(hsr1*hsr1+hsr2*hsr2+hsr3*hsr3)
  151. hsr1=hsr1*ba/br:hsr2=hsr2*ba/br:hsr3=hsr3*ba/br
  152. ca(1)=bm1-hsr1:ca(2)=bm2-hsr2:ca(3)=bm3-hsr3
  153. CLS
  154. RETURN
  155. raytracing:
  156. nsh=-1:kh=0
  157. FOR I=0 TO nk
  158. IF I<>ns THEN
  159. nr=I:GOSUB Kugelschnipp
  160. IF k THEN IF kh=0 OR k<kh THEN nsh=I:kh=k
  161. END IF
  162. NEXT I
  163. IF kh<=0 THEN GOSUB schnittich:RETURN
  164. IF nsh=0 THEN farbe=15:RETURN
  165. ns=nsh:k=kh:nr=ns
  166. ON ku(ns,4) GOSUB kugspiegel,Kugelglas
  167. IF farbe=15 THEN RETURN
  168. GOTO raytracing
  169. Kugelschnipp:
  170. ras1=ca1-ku(nr,1):ras2=ca2-ku(nr,2):ras3=ca3-ku(nr,3)
  171. kffn1=2*(crr1*crr1+crr2*crr2+crr3*crr3)
  172. kffn2=2*(crr1*ras1+crr2*ras2+crr3*ras3)
  173. kffn3=ras1*ras1+ras2*ras2+ras3*ras3-ku(nr,0)*ku(nr,0)
  174. kffn4=kffn2*kffn2-2*kffn1*kffn3:IF kffn4<0 THEN k=0:RETURN
  175. k1=(-kffn2+SQR(kffn4))/kffn1:k2=(-kffn2-SQR(kffn4))/kffn1
  176. k=k1:IF k1>k2 THEN k=k2
  177. RETURN
  178. kugspiegel:
  179. r1=ca1+k*crr1-ku(nr,1):r2=ca2+k*crr2-ku(nr,2):r3=ca3+k*crr3-ku(nr,3)
  180. h=(crr1*r1+crr2*r2+crr3*r3)/(r1*r1+r2*r2+r3*r3)
  181. crr1=crr1-2*h*r1:crr2=crr2-2*h*r2:crr3=crr3-2*h*r3
  182. ca1=r1+ku(nr,1):ca2=r2+ku(nr,2):ca3=r3+ku(nr,3)
  183. ffn=ffn+1
  184. RETURN
  185. Kugelglas:
  186. GOSUB kugelglasreflex:IF kkb=1 THEN farbe=15:RETURN
  187. brz=brz1:GOSUB knackpunkt:GOSUB schnitt2
  188. brz=brz2:GOSUB knackpunkt
  189. ca1=ku(nr,1)-r1:ca2=ku(nr,2)-r2:ca3=ku(nr,3)-r3
  190. IF nf=2 THEN faam=16 ELSE ffn=ffn+2
  191. RETURN
  192. kugelglasreflex:
  193. kkb=1
  194. r1=ca1+k*crr1-ku(nr,1):r2=ca2+k*crr2-ku(nr,2):r3=ca3+k*crr3-ku(nr,3)
  195. h=(crr1*r1+crr2*r2+crr3*r3)/(r1*r1+r2*r2+r3*r3)
  196. puma1=crr1-2*h*r1:puma2=crr2-2*h*r2:puma3=crr3-2*h*r3
  197. cah1=r1+ku(nr,1):cah2=r2+ku(nr,2):cah3=r3+ku(nr,3)
  198. ras1=cah1-ku(0,1):ras2=cah2-ku(0,2):ras3=cah3-ku(0,3)
  199. kffn1=2*(puma1*puma1+puma2*puma2+puma3*puma3)
  200. kffn2=2*(puma1*ras1+puma2*ras2+puma3*ras3)
  201. kffn3=ras1*ras1+ras2*ras2+ras3*ras3-ku(0,0)*ku(0,0)
  202. kffn4=kffn2*kffn2-2*kffn1*kffn3:IF kffn4<0 THEN kkb=0
  203. RETURN
  204. knackpunkt:
  205. r1=ku(nr,1)-ca1-k*crr1:r2=ku(nr,2)-ca2-k*crr2:r3=ku(nr,3)-ca3-k*crr3
  206. gf1=crr1*r1+crr2*r2+crr3*r3:gf2=crr1*crr1+crr2*crr2+crr3*crr3:gf3=r1*r1+r2*r2+r3*r3
  207. gf4=(gf1*gf1)/(gf2*gf3):gf5=(1-gf4)/brz
  208. si=SQR(ABS(gf5)):co=SQR(ABS(1-gf5))
  209. gh1=r2*crr3-r3*crr2=r3*crr1-r1*crr3:gh3=r1*crr2-r2*crr1
  210. g1=gh2*r3-gh3*r2:g2=gh3*r1-gh1*r3:g3=gh1*r2-gh2*r1
  211. gr=co/SQR(ABS(gf3)):gg=si/SQR(ABS(g1*g1+g2*g2+g3*g3))
  212. crr1=r1*gr+g1*gg:crr2=r2*gr+g2*gg:crr3=r3*gr+g3*gg
  213. RETURN
  214. schnitt2:
  215. kffn1=2*(crr1*crr1+crr2*crr2+crr3*crr3)
  216. kffn2=2*(crr1*r1+crr2*r2+crr3*r3)
  217. kffn3=gf3-ku(nr,0)*ku(nr,0)
  218. kffn4=kffn2*kffn2-2*kffn1*kffn3:IF kffn4<0 THEN k=0:RETURN
  219. k1=(-kffn2+SQR(kffn4))/kffn1:k2=(-kffn2-SQR(kffn4))/kffn1
  220. k=k1:IF k1<k2 THEN k=k2
  221. RETURN
  222. schnittich:
  223. IF crr3>=0 THEN IF ffn>3 THEN farbe=0+faam ELSE farbe=4-ffn+faam:RETURN
  224. bodk=ca3/crr3
  225. s1=ca1-bodk*crr1:s2=ca2-bodk*crr2
  226. GOSUB schatten
  227. IF ffn>4 THEN farbe=0+faam:RETURN
  228. IF INT(s1*.05)*2-INT(si*.1)=INT(s2*.05)*2-INT(s2*.1) THEN
  229.   farbe=9-ffn+faam
  230. ELSE
  231.   farbe=14-ffn+faam
  232. END IF
  233. RETURN
  234. schatten:
  235. fh=0
  236. ca1=s1:ca2=s2:ca3=0
  237. crr1=lqq1-s1:crr2=lqq2-s2:crr3=lqq3
  238. FOR j=1 TO nk
  239. nr=j:GOSUB Kugelschnipp
  240. IF k>0 THEN
  241. IF ku(nr,4)=1 THEN ffn=ffn+2:RETURN
  242. fh=fh+1
  243. END IF
  244. NEXT j
  245. IF fh>2 THEN fh=2
  246. ffn=ffn+fh
  247. RETURN
  248. savebild:
  249. PUT(280,0),grh,PSET:BEEP
  250. OPEN"O",#1,"Picture/"+na$+nn$,5000
  251. FOR I=0 TO yh
  252. GET(0,I)-(px,I),g#
  253. FOR j=0 TO ngg
  254. PRINT#1,MKD$(g#(j));
  255. NEXT j
  256. NEXT I
  257. CLOSE #1:BEEP
  258. RETURN
  259. loadbild:
  260. BEEP
  261. yh=bka-lka:IF yh=0 THEN yh=py
  262. OPEN"I",#1,"Picture/"+na$+nn$,5000
  263. I=0
  264. WHILE NOT EOF(1)
  265. FOR j=0 TO ngg
  266. g#(j)=CVD(INPUT$(8,#1))
  267. NEXT j
  268. PUT(0,I),g#
  269. I=I+1
  270. WEND
  271. CLOSE#1:BEEP
  272. RETURN
  273. showa:
  274. CLS:INPUT"Name (e=ende) ";na$:IF na$="e" THEN RUN
  275. SCREEN 2,640,512,4,4:WINDOW 2,,(0,0)-(631,498),0,2
  276. GOSUB palettea:GOSUB loadbild
  277. SLEEP:SLEEP:SLEEP
  278. GOTO showa
  279. showb:
  280. CLS:INPUT"Name (e=ende) ";na$:IF na$="e" THEN RUN
  281. SCREEN 2,321,257,5,1:WINDOW 2,,(0,0)-(312,243),0,2
  282. GOSUB palettea:GOSUB paletteb:GOSUB loadbild
  283. SLEEP:SLEEP:SLEEP
  284. GOTO showb
  285.  
  286.  
  287.  
  288.  
  289.  
  290.  
  291.